home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / sparc / c-call.lisp < prev    next >
Encoding:
Text File  |  1992-05-19  |  6.3 KB  |  181 lines
  1. ;;; -*- Package: SPARC -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: c-call.lisp,v 1.9 92/04/28 15:41:03 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; This file contains the VOPs and other necessary machine specific support
  15. ;;; routines for call-out to C.
  16. ;;;
  17. ;;; Written by William Lott.
  18. ;;;
  19. (in-package "SPARC")
  20. (use-package "ALIEN")
  21. (use-package "ALIEN-INTERNALS")
  22.  
  23. (defun my-make-wired-tn (prim-type-name sc-name offset)
  24.   (make-wired-tn (primitive-type-or-lose prim-type-name *backend*)
  25.          (sc-number-or-lose sc-name *backend*)
  26.          offset))
  27.  
  28. (defstruct arg-state
  29.   (register-args 0)
  30.   ;; No matter what we have to allocate at least 7 stack frame slots.  One
  31.   ;; because the C call convention requries it, and 6 because whoever we call
  32.   ;; is going to expect to be able to save his 6 register arguments there.
  33.   (stack-frame-size 7))
  34.  
  35. (defun int-arg (state prim-type reg-sc stack-sc)
  36.   (let ((reg-args (arg-state-register-args state)))
  37.     (cond ((< reg-args 6)
  38.        (setf (arg-state-register-args state) (1+ reg-args))
  39.        (my-make-wired-tn prim-type reg-sc (+ reg-args nl0-offset)))
  40.       (t
  41.        (let ((frame-size (arg-state-stack-frame-size state)))
  42.          (setf (arg-state-stack-frame-size state) (1+ frame-size))
  43.          (my-make-wired-tn prim-type stack-sc (+ frame-size 16)))))))
  44.  
  45. (def-alien-type-method (integer :arg-tn) (type state)
  46.   (if (alien-integer-type-signed type)
  47.       (int-arg state 'signed-byte-32 'signed-reg 'signed-stack)
  48.       (int-arg state 'unsigned-byte-32 'unsigned-reg 'unsigned-stack)))
  49.  
  50. (def-alien-type-method (system-area-pointer :arg-tn) (type state)
  51.   (declare (ignore type))
  52.   (int-arg state 'system-area-pointer 'sap-reg 'sap-stack))
  53.  
  54. (def-alien-type-method (integer :result-tn) (type)
  55.   (if (alien-integer-type-signed type)
  56.       (my-make-wired-tn 'signed-byte-32 'signed-reg nl0-offset)
  57.       (my-make-wired-tn 'unsigned-byte-32 'unsigned-reg nl0-offset)))
  58.   
  59. (def-alien-type-method (system-area-pointer :result-tn) (type)
  60.   (declare (ignore type))
  61.   (my-make-wired-tn 'system-area-pointer 'sap-reg nl0-offset))
  62.  
  63. (def-alien-type-method (double-float :result-tn) (type)
  64.   (declare (ignore type))
  65.   (my-make-wired-tn 'double-float 'double-reg 0))
  66.  
  67. (def-alien-type-method (values :result-tn) (type)
  68.   (mapcar #'(lambda (type)
  69.           (invoke-alien-type-method :result-tn type))
  70.       (alien-values-type-values type)))
  71.  
  72.  
  73. (def-vm-support-routine make-call-out-tns (type)
  74.   (declare (type alien-function-type type))
  75.   (let ((arg-state (make-arg-state)))
  76.     (collect ((arg-tns))
  77.       (dolist (arg-type (alien-function-type-arg-types type))
  78.     (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
  79.       (values (my-make-wired-tn 'positive-fixnum 'any-reg nsp-offset)
  80.           (* (arg-state-stack-frame-size arg-state) word-bytes)
  81.           (arg-tns)
  82.           (invoke-alien-type-method
  83.            :result-tn
  84.            (alien-function-type-result-type type))))))
  85.  
  86. (deftransform %alien-funcall ((function type &rest args))
  87.   (assert (c::constant-continuation-p type))
  88.   (let* ((type (c::continuation-value type))
  89.      (arg-types (alien-function-type-arg-types type))
  90.      (result-type (alien-function-type-result-type type)))
  91.     (assert (= (length arg-types) (length args)))
  92.     (if (some #'alien-double-float-type-p arg-types)
  93.     (collect ((new-args) (lambda-vars) (new-arg-types))
  94.       (dolist (type arg-types)
  95.         (let ((arg (gensym)))
  96.           (lambda-vars arg)
  97.           (cond ((alien-double-float-type-p type)
  98.              (new-args `(double-float-high-bits ,arg))
  99.              (new-args `(double-float-low-bits ,arg))
  100.              (new-arg-types (parse-alien-type '(signed 32)))
  101.              (new-arg-types (parse-alien-type '(unsigned 32))))
  102.             (t
  103.              (new-args arg)
  104.              (new-arg-types type)))))
  105.       `(lambda (function type ,@(lambda-vars))
  106.          (declare (ignore type))
  107.          (%alien-funcall function
  108.                  ',(make-alien-function-type
  109.                 :arg-types (new-arg-types)
  110.                 :result-type result-type)
  111.                  ,@(new-args))))
  112.     (c::give-up))))
  113.  
  114.  
  115. (define-vop (foreign-symbol-address)
  116.   (:translate foreign-symbol-address)
  117.   (:policy :fast-safe)
  118.   (:args)
  119.   (:arg-types (:constant simple-string))
  120.   (:info foreign-symbol)
  121.   (:results (res :scs (sap-reg)))
  122.   (:result-types system-area-pointer)
  123.   (:generator 2
  124.     (inst li res (make-fixup (concatenate 'simple-string "_" foreign-symbol)
  125.                  :foreign))))
  126.  
  127. (define-vop (call-out)
  128.   (:args (function :scs (sap-reg) :target cfunc)
  129.      (args :more t))
  130.   (:results (results :more t))
  131.   (:ignore args results)
  132.   (:save-p t)
  133.   (:temporary (:sc any-reg :offset cfunc-offset
  134.            :from (:argument 0) :to (:result 0)) cfunc)
  135.   (:temporary (:sc interior-reg :offset lip-offset) lip)
  136.   (:temporary (:scs (any-reg) :to (:result 0)) temp)
  137.   (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
  138.   (:vop-var vop)
  139.   (:generator 0
  140.     (let ((cur-nfp (current-nfp-tn vop)))
  141.       (when cur-nfp
  142.     (store-stack-tn nfp-save cur-nfp))
  143.       (move cfunc function)
  144.       (inst li temp (make-fixup "_call_into_c" :foreign))
  145.       (inst jal lip temp)
  146.       (inst nop)
  147.       (when cur-nfp
  148.     (load-stack-tn cur-nfp nfp-save)))))
  149.  
  150.  
  151. (define-vop (alloc-number-stack-space)
  152.   (:info amount)
  153.   (:results (result :scs (sap-reg any-reg)))
  154.   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
  155.   (:generator 0
  156.     (unless (zerop amount)
  157.       (let ((delta (logandc2 (+ amount 7) 7)))
  158.     (cond ((< delta (ash 1 12))
  159.            (inst sub nsp-tn delta))
  160.           (t
  161.            (inst li temp delta)
  162.            (inst sub nsp-tn temp)))))
  163.     (unless (location= result nsp-tn)
  164.       ;; They are only location= when the result tn was allocated by
  165.       ;; make-call-out-tns above, which takes the number-stack-displacement
  166.       ;; into account itself.
  167.       (inst add result nsp-tn number-stack-displacement))))
  168.  
  169. (define-vop (dealloc-number-stack-space)
  170.   (:info amount)
  171.   (:policy :fast-safe)
  172.   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
  173.   (:generator 0
  174.     (unless (zerop amount)
  175.       (let ((delta (logandc2 (+ amount 7) 7)))
  176.     (cond ((< delta (ash 1 12))
  177.            (inst add nsp-tn delta))
  178.           (t
  179.            (inst li temp delta)
  180.            (inst add nsp-tn temp)))))))
  181.